home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / kcl-patches.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  10.5 KB  |  313 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28.  
  29. (in-package "COMPILER")
  30.  
  31. #+akcl
  32. (eval-when (compile load eval)
  33. (when (<= system::*akcl-version* 609)
  34.   (pushnew :pre_akcl_610 *features*))
  35. )
  36.  
  37. #+akcl
  38. (progn
  39.  
  40. ;There is a bug in the implementation of *print-circle* that
  41. ;causes some akcl debugging commands (including :bt and :bl)
  42. ;to cause the following error when PCL is being used:
  43. ;Unrecoverable error: value stack overflow.
  44.  
  45. ;When a CLOS object is printed, travel_push_object ends up
  46. ;traversing almost the whole class structure, thereby overflowing
  47. ;the value-stack.
  48.  
  49. ;from lsp/debug.lsp.
  50. ;*print-circle* is badly implemented in kcl.
  51. ;it has two separate problems that should be fixed:
  52. ;  1. it traverses the printed object putting all objects found
  53. ;     on the value stack (rather than in a hash table or some
  54. ;     other structure; this is a problem because the size of the value stack
  55. ;     is fixed, and a potentially unbounded number of objects
  56. ;     need to be traversed), and
  57. ;  2. it blindly traverses all slots of any
  58. ;     kind of structure including std-object structures.
  59. ;     This is safe, but not always necessary, and is very time-consuming
  60. ;     for CLOS objects (because it will always traverse every class).
  61.  
  62. ;For now, avoid using *print-circle* T when it will cause problems.
  63.  
  64. (eval-when (compile eval)
  65. (defmacro si::f (op &rest args)
  66.     `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
  67.  
  68. (defmacro si::fb (op &rest args)
  69.     `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
  70. )
  71.  
  72. (defun si::display-env (n env)
  73.   (do ((v (reverse env) (cdr v)))
  74.       ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
  75.     (or (and (consp (car v))
  76.          (listp (cdar v)))
  77.     (return))
  78.     (let ((*print-circle* (can-use-print-circle-p (cadar v))))
  79.       (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))
  80.  
  81. (defun si::display-compiled-env ( plength ihs &aux
  82.                       (base (si::ihs-vs ihs))
  83.                       (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
  84.   (format si::*display-string* "")
  85.   (do ((i base )
  86.        (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
  87.       ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
  88.     (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
  89.     (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
  90.         (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
  91.         (si::fb < (setq i (si::f + i 1)) end)))))
  92.  
  93. (clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")
  94. (defentry objnull-p (object) (object "objnull_p"))
  95.  
  96. (defun can-use-print-circle-p (x)
  97.   (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?
  98.        (typecase x
  99.      (vector  (or (not (eq 't (array-element-type x)))
  100.               (every #'can-use-print-circle-p x)))
  101.      (cons    (and (can-use-print-circle-p (car x))
  102.                (can-use-print-circle-p (cdr x))))
  103.      (array   (or (not (eq 't (array-element-type x)))
  104.               (let* ((rank (array-rank x))
  105.                  (dimensions (make-list rank)))
  106.             (dotimes (i rank)
  107.               (setf (nth i dimensions) (array-dimension x i)))
  108.             (or (member 0 dimensions)
  109.                 (do ((cursor (make-list rank :initial-element 0)))
  110.                 (nil)
  111.                   (declare (:dynamic-extent cursor))
  112.                   (unless (can-use-print-circle-p (apply #'aref x cursor))
  113.                 (return nil))
  114.                   (when (si::increment-cursor cursor dimensions)
  115.                 (return t)))))))
  116.      (t (or (not (si:structurep x))
  117.         (let* ((def (si:structure-def x))
  118.                (name (si::s-data-name def))
  119.                (len (si::s-data-length def))
  120.                (pfun (si::s-data-print-function def)))
  121.           (and (null pfun)
  122.                (dotimes (i len t)
  123.              (unless (can-use-print-circle-p (si:structure-ref x name i))
  124.                (return nil))))))))))
  125.  
  126. (defun si::apply-display-fun (display-fun  n lis)  
  127.   (let ((*print-length* si::*debug-print-level*)
  128.     (*print-level* si::*debug-print-level*)
  129.     (*print-pretty* nil)
  130.     (*PRINT-CASE* :downcase)
  131.     (*print-circle* nil)
  132.     )
  133.     (setf (fill-pointer si::*display-string*) 0)
  134.     (format si::*display-string* "{")
  135.     (funcall display-fun n lis)
  136.     (when (si::fb > (fill-pointer si::*display-string*) n)
  137.       (setf (fill-pointer si::*display-string*) n)
  138.       (format si::*display-string* "..."))
  139.  
  140.     (format si::*display-string* "}")
  141.     )
  142.   si::*display-string*
  143.   )
  144.  
  145. ;The old definition of this had a bug:
  146. ;sometimes it returned without calling mv-values.
  147. (defun si::next-stack-frame (ihs &aux line-info li i k na)
  148.   (cond ((si::fb < ihs si::*ihs-base*)
  149.      (si::mv-values nil nil nil nil nil))
  150.     ((let (fun)
  151.        ;; next lower visible ihs
  152.        (si::mv-setq (fun i) (si::get-next-visible-fun ihs))
  153.        (setq na fun)
  154.        (cond ((and (setq line-info (get fun 'si::line-info))
  155.                (do ((j (si::f + ihs 1) (si::f - j 1))
  156.                 (form ))
  157.                ((<= j i) nil)
  158.              (setq form (si::ihs-fun j))
  159.              (cond ((setq li (si::get-line-of-form form line-info))
  160.                 (return-from si::next-stack-frame 
  161.                   (si::mv-values
  162.                    i fun li
  163.                    ;; filename
  164.                    (car (aref line-info 0))
  165.                    ;;environment
  166.                    (list (si::vs (setq k (si::ihs-vs j)))
  167.                      (si::vs (1+ k))
  168.                      (si::vs (+ k 2)))))))))))))
  169.     ((and (not (special-form-p na))
  170.           (not (get na 'si::dbl-invisible))
  171.           (fboundp na))
  172.      (si::mv-values i na nil nil
  173.             (if (si::ihs-not-interpreted-env i)
  174.             nil
  175.             (let ((i (si::ihs-vs i)))
  176.               (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))
  177.     (t (si::mv-values nil nil nil nil nil))))
  178. )
  179.  
  180. #+pre_akcl_610
  181. (progn
  182.  
  183. ;(proclaim '(optimize (safety 0) (speed 3) (space 1)))
  184.  
  185. ;Not needed... make-top-level-form generates defuns now.
  186. ;(setq compiler::*compile-ordinaries* t)
  187.  
  188. (eval-when (compile load eval)
  189. (unless (fboundp 'original-co1typep)
  190.   (setf (symbol-function 'original-co1typep) #'co1typep))
  191. )
  192.  
  193. (defun new-co1typep (f args)
  194.   (or (original-co1typep f args)
  195.       (let ((x (car args))
  196.         (type (cadr args)))
  197.     (when (constantp type)
  198.       (let ((ntype (si::normalize-type (eval type))))
  199.         (when (and (eq (car ntype) 'satisfies)
  200.                (cadr ntype)
  201.                (symbolp (cadr ntype))
  202.                (symbol-package (cadr ntype)))
  203.           (c1expr `(the boolean (,(cadr ntype) ,x)))))))))
  204.  
  205. (setf (symbol-function 'co1typep) #'new-co1typep)
  206.  
  207. )
  208.  
  209. #-(or akcl xkcl)
  210. (progn
  211. (in-package 'system)
  212.  
  213. ;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
  214. ;;;   in the lambda-list.  The former allows deviation from the CL spec,
  215. ;;;   but what the heck.
  216.  
  217. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  218.  
  219. (defvar *old-defmacro*)
  220.  
  221. (defun new-defmacro (whole env)
  222.   (flet ((call-old-definition (new-whole)
  223.        (funcall *old-defmacro* new-whole env)))
  224.     (if (not (and (consp whole)
  225.           (consp (cdr whole))
  226.           (consp (cddr whole))
  227.           (consp (cdddr whole))))
  228.     (call-old-definition whole)
  229.     (let* ((ll (caddr whole))
  230.            (env-tail (do ((tail ll (cdr tail)))
  231.                  ((not (consp tail)) nil)
  232.                (when (eq '&environment (car tail))
  233.                  (return tail)))))
  234.       (if env-tail
  235.           (call-old-definition (list* (car whole)
  236.                       (cadr whole)
  237.                       (append (list '&environment
  238.                             (cadr env-tail))
  239.                           (ldiff ll env-tail)
  240.                           (cddr env-tail))
  241.                       (cdddr whole)))
  242.           (call-old-definition whole))))))
  243.  
  244. (eval-when (load eval)
  245.   (unless (boundp '*old-defmacro*)
  246.     (setq *old-defmacro* (macro-function 'defmacro))
  247.     (setf (macro-function 'defmacro) #'new-defmacro)))
  248.  
  249. ;;;
  250. ;;; setf patches
  251. ;;;
  252.  
  253. (defun get-setf-method (form)
  254.   (multiple-value-bind (vars vals stores store-form access-form)
  255.       (get-setf-method-multiple-value form)
  256.     (unless (listp vars)
  257.         (error 
  258.  "The temporary variables component, ~s, 
  259.   of the setf-method for ~s is not a list."
  260.              vars form))
  261.     (unless (listp vals)
  262.         (error 
  263.  "The values forms component, ~s, 
  264.   of the setf-method for ~s is not a list."
  265.              vals form))
  266.     (unless (listp stores)
  267.         (error 
  268.  "The store variables component, ~s,  
  269.   of the setf-method for ~s is not a list."
  270.              stores form))
  271.     (unless (= (list-length stores) 1)
  272.         (error "Multiple store-variables are not allowed."))
  273.     (values vars vals stores store-form access-form)))
  274.  
  275. (defun get-setf-method-multiple-value (form)
  276.   (cond ((symbolp form)
  277.      (let ((store (gensym)))
  278.        (values nil nil (list store) `(setq ,form ,store) form)))
  279.     ((or (not (consp form)) (not (symbolp (car form))))
  280.      (error "Cannot get the setf-method of ~S." form))
  281.     ((get (car form) 'setf-method)
  282.      (apply (get (car form) 'setf-method) (cdr form)))
  283.     ((get (car form) 'setf-update-fn)
  284.      (let ((vars (mapcar #'(lambda (x)
  285.                              (declare (ignore x))
  286.                              (gensym))
  287.                          (cdr form)))
  288.            (store (gensym)))
  289.        (values vars (cdr form) (list store)
  290.                `(,(get (car form) 'setf-update-fn)
  291.              ,@vars ,store)
  292.            (cons (car form) vars))))
  293.     ((get (car form) 'setf-lambda)
  294.      (let* ((vars (mapcar #'(lambda (x)
  295.                               (declare (ignore x))
  296.                               (gensym))
  297.                           (cdr form)))
  298.         (store (gensym))
  299.         (l (get (car form) 'setf-lambda))
  300.         (f `(lambda ,(car l) 
  301.               (funcall #'(lambda ,(cadr l) ,@(cddr l))
  302.                    ',store))))
  303.        (values vars (cdr form) (list store)
  304.            (apply f vars)
  305.            (cons (car form) vars))))
  306.     ((macro-function (car form))
  307.      (get-setf-method-multiple-value (macroexpand-1 form)))
  308.     (t
  309.      (error "Cannot expand the SETF form ~S." form))))
  310.  
  311. )
  312.  
  313.